home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / m20arithgen.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  9.3 KB  |  202 lines
  1. (herald (back_end m682arithgen)
  2.   (env t (orbit_top defs) (back_end bookkeep)))
  3.                       
  4. (define (generate-two-fixnums node compare?)
  5.   (destructure (((then else () ref1 ref2) (call-args node)))
  6.     (let ((val1 (leaf-value ref1))
  7.           (reg2 (let ((reg (get-register 'scratch node '*)))
  8.                   (generate-move (access-with-rep node (leaf-value ref2)
  9.                           'rep/pointer) reg)
  10.                   reg)))
  11.       (lock reg2)
  12.       (let ((reg1 (let ((reg (get-register 'scratch node '*)))
  13.                                 (generate-move (access-with-rep node val1
  14.                                 'rep/pointer)
  15.                            reg)
  16.                                 reg)))
  17.         (unlock reg2)                 
  18.         (generate-move reg1 SCRATCH)
  19.         (if (variable? (leaf-value ref2)) 
  20.             (emit m68/or .w reg2 SCRATCH))
  21.         (emit m68/and .b (machine-num 3) SCRATCH)
  22.         (emit-jump jump-op/jn= else then)      
  23.         (or compare?
  24.            (destructure (((arg1 arg2) (lambda-variables then)))
  25.              (mark arg1 reg1)
  26.              (mark arg2 reg2)))))))
  27.  
  28. (define (generate-op-with-overflow node op) 
  29.   (destructure (((then else () ref1 ref2) (call-args node)))
  30.     (let ((reg1 (register-loc (leaf-value ref1)))
  31.           (reg2 (register-loc (leaf-value ref2))))
  32.       (xcase op
  33.     ((add) (emit m68/add .l reg2 reg1))
  34.     ((subtract) (emit m68/sub .l reg2 reg1))
  35.     ((multiply)
  36.      (emit m68/asr .l ($ 2) reg1)
  37.      (emit m68/mulsl reg2 reg1)))
  38.       (emit-jump jump-op/overflow then else)
  39.       (kill (leaf-value ref1))
  40.       (kill (leaf-value ref2))
  41.       (mark (car (lambda-variables else)) reg1))))
  42.  
  43. (define (generate-hack-dr node op)
  44.   (destructure (((#f ref1 ref2) (call-args node)))
  45.     (let ((reg1 (register-loc (leaf-value ref1)))
  46.           (reg2 (register-loc (leaf-value ref2))))
  47.       (xcase op
  48. ;    ((divide)
  49. ;     (emit m68/divsl reg2 scratch reg1)
  50. ;     (emit m68/asl .l ($ 2) reg1))
  51.     ((remainder)
  52.      (emit m68/divsl reg2 scratch reg1)
  53.      (generate-move scratch reg1)))
  54.       (kill (leaf-value ref1))
  55.       (kill (leaf-value ref2))
  56.       (mark-continuation node reg1))))
  57.   
  58.  
  59. (define-constant (opposite rep)
  60.   (case rep
  61.     ((rep/pointer) 'rep/integer)
  62.     (else 'rep/pointer)))
  63.  
  64. (define-constant (same rep)
  65.   (if (eq? rep 'rep/pointer) rep 'rep/integer))
  66.  
  67. (define (generate-fixnum-multiply node)
  68.   (destructure (((cont right left) (call-args node)))
  69.     (let ((lvar (leaf-value left))
  70.           (rvar (leaf-value right)))
  71.       (receive (t-spec t-rep) (continuation-wants cont)
  72.         (receive (l-rep r-rep)
  73.                  (case t-rep
  74.                    ((rep/pointer)
  75.                     (cond ((variable? lvar) 
  76.                            (case (variable-rep lvar)
  77.                              ((rep/pointer)
  78.                               (if (and (variable? rvar) 
  79.                                        (eq? (variable-rep rvar) 'rep/pointer)
  80.                                        (let ((loc (register-loc lvar)))
  81.                                          (and (register? loc) 
  82.                                               (eq? (reg-type loc) 'scratch))))
  83.                                   (return 'rep/integer 'rep/pointer)
  84.                                   (return 'rep/pointer 'rep/integer)))
  85.                              (else
  86.                               (return 'rep/integer 'rep/pointer))))
  87.                           (else
  88.                            (return (opposite (variable-rep rvar))
  89.                                    (same (variable-rep rvar))))))
  90.                    (else
  91.                     (return 'rep/integer 'rep/integer)))       
  92.           (let ((l-acc (access-with-rep node lvar l-rep)))                      
  93.             (protect-access l-acc)                                              
  94.             (let ((r-acc (access-with-rep node rvar r-rep)))                    
  95.               (cond ((and (register? l-acc)                                     
  96.                           (eq? (reg-type l-acc) 'scratch)                       
  97.                           (dying? lvar node))                                  
  98.                      (cond ((and (register? r-acc)
  99.                                  (eq? (reg-type r-acc) 'pointer))
  100.                             (generate-move r-acc SCRATCH)
  101.                             (emit m68/mulsl SCRATCH l-acc))
  102.                            (else                               
  103.                             (emit m68/mulsl r-acc l-acc)))                               
  104.                      (release-access l-acc)
  105.                      (kill lvar)                                                
  106.                      (mark-continuation node l-acc))                            
  107.                     ((and (register? r-acc)                                     
  108.                           (eq? (reg-type r-acc) 'scratch)                       
  109.                           (dying? rvar node))                                   
  110.                      (cond ((and (register? l-acc)
  111.                                  (eq? (reg-type l-acc) 'pointer))
  112.                             (generate-move l-acc SCRATCH)
  113.                             (emit m68/mulsl SCRATCH r-acc))
  114.                            (else                               
  115.                             (emit m68/mulsl l-acc r-acc)))                               
  116.                      (release-access l-acc)
  117.                      (kill rvar)                                                
  118.                      (mark-continuation node r-acc))                            
  119.                     (else
  120.                      (let ((t-reg (if (and (register? t-spec)                   
  121.                                            (eq? (reg-type t-spec) 'scratch)     
  122.                                            (maybe-free t-spec cont))            
  123.                                       t-spec                                    
  124.                                       (get-register 'scratch node '*))))        
  125.              (release-access l-acc)
  126.              (generate-move r-acc t-reg)                              
  127.                        (cond ((and (register? l-acc)                            
  128.                                    (eq? (reg-type l-acc) 'pointer))             
  129.                               (generate-move l-acc SCRATCH)                     
  130.                               (emit m68/mulsl SCRATCH t-reg))                   
  131.                              (else                                              
  132.                               (emit m68/mulsl l-acc t-reg)))                    
  133.                        (mark-continuation node t-reg)))))))))))                 
  134.                                 
  135. (define (generate-fixnum-divide node)
  136.   (generate-fixnum-dr node 'divide))
  137.  
  138. (define (generate-fixnum-remainder node)
  139.   (generate-fixnum-dr node 'remainder))
  140.  
  141. (define (generate-fixnum-dr node which)
  142.   (destructure (((cont right left) (call-args node)))
  143.     (receive (t-spec t-rep) (continuation-wants cont)
  144.       (let* ((lvar (leaf-value left))
  145.              (rvar (leaf-value right))
  146.              (l-acc (access-with-rep node lvar 'rep/integer)))
  147.         (protect-access l-acc)
  148.         (let ((r-acc (access-with-rep node rvar 'rep/integer)))
  149.           (release-access l-acc) 
  150.           (cond ((and (register? r-acc) 
  151.                       (dying? rvar node))
  152.                  (xcase which
  153.                    ((divide)
  154.                     (emit m68/divsl l-acc SCRATCH r-acc))
  155.                    ((remainder)
  156.                     (emit m68/divsl l-acc SCRATCH r-acc)
  157.                     (generate-move SCRATCH r-acc)))
  158.                  (if (eq? t-rep 'rep/pointer)
  159.                      (emit m68/asl .l (machine-num 2) r-acc))
  160.                  (kill rvar)
  161.                  (mark-continuation node r-acc))
  162.                 (else
  163.          (protect-access l-acc)
  164.                  (xcase (cond ((register? t-spec) (reg-type t-spec))
  165.                              (else t-spec))
  166.                    ((scratch *)
  167.                     (let ((t-reg (if (and (register? t-spec)
  168.                                           (not (reg-node t-spec)))
  169.                                      t-spec
  170.                                      (get-register 'scratch node '*))))
  171.              (release-access l-acc)
  172.                      (generate-move r-acc t-reg)
  173.                      (xcase which
  174.                        ((divide)
  175.                         (emit m68/divsl l-acc SCRATCH t-reg))
  176.                        ((remainder)
  177.                         (emit m68/divsl l-acc SCRATCH t-reg)
  178.                         (generate-move SCRATCH t-reg)))
  179.              (if (eq? t-rep 'rep/pointer)
  180.              (emit m68/asl .l (machine-num 2) t-reg))
  181.              (mark-continuation node t-reg)))
  182.                    ((pointer)
  183.                     (let* ((t-reg (if (and (register? t-spec)
  184.                                            (not (reg-node t-spec)))
  185.                                       t-spec
  186.                                       (get-register 'pointer node '*)))
  187.                            (extra (if (eq? which 'remainder)
  188.                                       (get-register 'scratch node '*)
  189.                                       SCRATCH)))
  190.              (release-access l-acc)
  191.              (generate-move r-acc SCRATCH)             
  192.                       (xcase which
  193.                         ((divide)
  194.                          (emit m68/divsl l-acc SCRATCH SCRATCH))
  195.                         ((remainder)
  196.                          (emit m68/divsl l-acc extra SCRATCH)))
  197.                       (emit m68/asl .l (machine-num 2) extra)
  198.                       (generate-move extra t-reg)
  199.               (mark-continuation node t-reg)))))))))))
  200.  
  201.  
  202.